perm filename CNTRL[C,JRA] blob
sn#018389 filedate 1973-01-02 generic text, type T, neo UTF8
00100
00200 (GLOBAL (FUNCTIONS @
00300 EAR
00400 TOP
00500 CINTERRUPT
00600 VFRAME
00700 CPRINT
00800 CPRIN1
00900 PROGBIND
01000 RUN
01100 START
01200 STOP
01300 PROG
01400 COND
01500 GO
01600 EXIT
01700 RETURN
01800 DISMISS
01900 CEVAL
02000 CERR
02100 CDEFUN
02200 VLOC
02300 RVALUE
02400 CSET
02500 CSETQ
02600 TAG
02700 ACTBLOCK
02800 UNASSIGN
02900 ACCESS
03000 CONTROL
03100 SETACCESS
03200 SETCONTROL
03300 EXPRESSION
03400 CLOSURE
03500 FRAME
03600 CALL
03700 BACKTRACE
03800 LISTEN
03900 CONTINUE
04000 ALLOW
04100 INVOKE
04200 :
04300 /,
04400 !>
04500 !'
04600 !?
04700 !;
04800 !"
04900 !@
05000 !<
05100 !/,)
05200 (RESERVED ←
05300 *FRAME
05400 CEXPR
05500 "OPTIONAL"
05600 "REST"
05700 "AUX"
05800 *
05900 **
06000 CLAMBDA
06100 *TAG
06200 *AU-REVOIR
06300 ?
06400 <
06500 >
06600 /'
06700 @
06800 "
06900 $
07000 ;
07100 /
07200 /
07300 /)))
07400
07500 (DECLARE (SPECIAL OBARRAY READTABLE ERRLIST) (SYMBOLS T) (MACROS T))
07600
07700 (DECLARE (SPECIAL UARGS
07800 BODY
07900 EARGS
08000 CHALOBV
08100 BVARS
08200 ALINK
08300 CLINK
08400 EXP
08500 FRAME*
08600 FREEVARS
08700 FRAMEVARS
08800 LEVNUM
08900 PC
09000 RUNF
09100 TEM
09200 TEM1
09300 TYPE
09400 VAL
09500 VARS
09600 CINTERRUPT
09700 SERRLI
09800 ALLOW
09900 READY
10000 GLOBALS
10100 *
10200 **
10300 ←)
10400 (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ : @ /,)
10500 (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN))
10600
10700 (SETQ RUNF
10800 NIL
10900 SERRLI
11000 NIL
11100 **
11200 (QUOTE **)
11300 GLOBALS
11400 (QUOTE ((NIL NIL) (T T))))
11500
11600 (COMMENT THE
11700 FRAME
11800 FORMAT
11900 IS
12000 AS
12100 FOLLOWS
12200 ((IVARS . PC) (BVARS . ALINK) EXP . CLINK))
12300
12400 (SETQ FREEVARS
12500 (QUOTE (VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW))
12600 FRAMEVARS
12700 (QUOTE
12800 (CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY)))
12900
13000 (DEFPROP BVARS (LAMBDA (L) (LIST (QUOTE CAADR) (CADR L))) MACRO)
13100
13200 (DEFPROP ALINK (LAMBDA (L) (LIST (QUOTE CDADR) (CADR L))) MACRO)
13300
13400 (DEFPROP EXP (LAMBDA (L) (LIST (QUOTE CADDR) (CADR L))) MACRO)
13500
13600 (DEFPROP CLINK (LAMBDA (L) (LIST (QUOTE CDDDR) (CADR L))) MACRO)
13700
13800 (DEFPROP BODY
13900 (LAMBDA (L) (QUOTE (CADR (ASSQ (QUOTE *BODY) BVARS))))
14000 MACRO)
14100 (COMMENT THE HACK REALLY BEGINS HERE 0 0 RUN1 IS THE SYSTEM DRIVER)
14200
14300 (DEFPROP RUN
14400 (LAMBDA L
14500 (PROG NIL
14600 (SETQ VAL (COND ((= L 1) (ARG 1)) (T NIL)))
14700 (RETURN (RUN1))))
14800 EXPR)
14900
15000 (DEFPROP RUN1
15100 (LAMBDA NIL
15200 (PROG NIL
15300 (COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
15400 (RETURN
15500 ((LAMBDA(BASE IBASE READTABLE)
15600 (PROG (RUNF ERET)
15700 (SETQ RUNF T)
15800 (SETQ ERRLIST SERRLI)
15900 ERRL (SETQ ERET
16000 (CATCH
16100 (PROG NIL
16200 LOOP (COND
16300 ((AND CINTERRUPT ALLOW)
16400 (SETQ PC (HANDLE)))
16500 ((SETQ PC (CAP PC))))
16600 (GO LOOP))))
16700 (COND ((EQ ERET (QUOTE STOP)) (RETURN VAL)))
16800 (GO ERRL)))
16900 12
17000 12
17100 (GET (QUOTE CONNIVREAD) (QUOTE ARRAY))))))
17200 EXPR)
17300
17400 (DEFPROP CAP (LAMBDA (P) (APPLY P NIL)) EXPR)
17500
17600 (DEFPROP HANDLE
17700 (LAMBDA NIL
17800 (PROG2 0
17900 (DISPATCH (PROG2 0
18000 (CAR CINTERRUPT)
18100 (SETQ CINTERRUPT (CDR CINTERRUPT)))
18200 PC
18300 FREEVARS
18400 (QUOTE *TOP))
18500 (SETQ ALLOW NIL)))
18600 EXPR)
18700
18800 (DEFPROP START
18900 (LAMBDA NIL
19000 (PROG NIL
19100 (COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
19200 (MAPC (QUOTE (LAMBDA (V) (SET V NIL)))
19300 (APPEND FRAMEVARS FREEVARS))
19400 (SETQ PC (QUOTE ICEVAL))
19500 (SETQ EXP
19600 (QUOTE
19700 (CEVAL (QUOTE (LISTEN (QUOTE TOP-LEVEL))))))
19800 (SETQ LEVNUM 0)
19900 (SETQ ALLOW T)
20000 (RETURN (RUN1))))
20100 EXPR)
20200
20300 (DEFPROP STOP
20400 (LAMBDA N
20500 (PROG NIL
20600 (BREAK CONNIVER-NOT-RUNNING--STOP (NOT RUNF))
20700 (COND ((= N 0) (SETQ VAL NIL))
20800 ((= N 1) (SETQ VAL (ARG 1)))
20900 (T (CERR WRONG # OF ARGS)))
21000 (SETQ PC (QUOTE POPJ))
21100 (RETURN (THROW (QUOTE STOP)))))
21200 EXPR)
21300
21400 (DEFPROP *STOP
21500 (LAMBDA NIL
21600 (PROG NIL
21700 (SETQ PC (QUOTE U-LOSE))
21800 (RETURN (THROW (QUOTE STOP)))))
21900 EXPR)
22000
22100 (DEFPROP U-LOSE
22200 (LAMBDA NIL
22300 (PROG NIL
22400 (CERR ATTEMPT
22500 TO
22600 RUN
22700 A
22800 CONNIVER
22900 PROCESS
23000 WITH
23100 AN
23200 UNDEFINED
23300 PC)
23400 (RETURN (QUOTE U-LOSE))))
23500 EXPR)
23600
23700 (DF CERR(L A) NIL)
23800 (DEFPROP EAR
23900 (LAMBDA NIL
24000 (PROG NIL
24100 (SETQ CINTERRUPT
24200 (CONS
24300 (QUOTE (LISTEN (QUOTE IN-CONNIVER)))
24400 CINTERRUPT))
24500 (SETQ SERRLI ERRLIST)
24600 (SETQ ERRLIST (QUOTE ((RUN1))))
24700 (RETURN (IOC G))))
24800 EXPR)
24900
25000 (DEFPROP TOP
25100 (LAMBDA NIL
25200 (PROG NIL
25300 (SETQ SERRLI ERRLIST)
25400 (SETQ ERRLIST (QUOTE ((START))))
25500 (RETURN (IOC G))))
25600 EXPR)
25700
25800 (DEFPROP CINTERRUPT
25900 (LAMBDA(EXP)
26000 (NCONC (GET (QUOTE CINTERRUPT) (QUOTE VALUE)) (LIST EXP)))
26100 EXPR)
26200
26300 (DEFPROP ALLOW (LAMBDA (L) (SETQ ALLOW (CAR L))) FEXPR)
26400
26500 (COMMENT DISPATCH IS THE "PUSHJ" FOR CONNIVER)
26600
26700 (DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))
26800
26900 (DEFPROP DISPATCH
27000 (LAMBDA(EXP1 RETAG SAVE ALINK1)
27100 (COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
27200 ((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
27300 (T
27400 (PROG (V F)
27500 (SETQ F (CAR EXP1))
27600 BEGIN
27700 (COND
27800 ((ATOM F)
27900 (COND
28000 ((SETQ V
28100 (GETL F
28200 (QUOTE
28300 (CINT CEXPR FEXPR FSUBR))))
28400 (GO (CAR V)))
28500 (T (SAVEUP)
28600 (SETQ UARGS (CDR EXP1))
28700 (SETQ EARGS NIL)
28800 (RETURN (QUOTE EVARGS)))))
28900 ((EQ (CAR F) (QUOTE CLAMBDA))
29000 (SAVEUP)
29100 (BIND1 (QUOTE *BODY) (CDDR F))
29200 (SETQ VARS (CADR F))
29300 (SETQ UARGS (CDR EXP1))
29400 (RETURN (QUOTE ARGB)))
29500 ((EQ (CAR F) (QUOTE LAMBDA . NIL))
29600 (SAVEUP)
29700 (SETQ UARGS (CDR EXP1))
29800 (SETQ EARGS NIL)
29900 (RETURN (QUOTE EVARGS)))
30000 ((EQ (CAR F) (QUOTE *CLOSURE))
30100 (SETQ F (CADR F))
30200 (GO BEGIN))
30300 (T (SETQ F
30400 (CERR UNKNOWN
30500 FUNCTION
30600 TYPE
30700 (@ . EXP1)))
30800 (GO BEGIN)))
30900 CINT (SAVEUP)
31000 (RETURN (CADR V))
31100 CEXPR
31200 (SAVEUP)
31300 (BIND1 (QUOTE *BODY) (CDADR V))
31400 (SETQ VARS (CAADR V))
31500 (SETQ UARGS (CDR EXP1))
31600 (RETURN (QUOTE ARGB))
31700 FEXPR
31800 FSUBR
31900 (SETQ VAL (EVAL EXP1))
32000 (RETURN RETAG)))))
32100 EXPR)
32200
32300 (DEFPROP SAVEUP
32400 (LAMBDA NIL
32500 (PROG NIL
32600 (SETQ CLINK
32700 (CONS (CONS (SAVEV) RETAG)
32800 (COND
32900 ((NULL FRAME*)
33000 (SETQ CHALOBV NIL)
33100 (CONS (CONS BVARS ALINK)
33200 (CONS EXP CLINK)))
33300 (CHALOBV (SETQ CHALOBV NIL)
33400 (CONS
33500 (CONS BVARS ALINK)
33600 (CDDR FRAME*)))
33700 (T (CDR FRAME*)))))
33800 (SETQ EXP EXP1)
33900 (SETQ ALINK
34000 (COND
34100 ((EQ ALINK1 (QUOTE *TOP)) CLINK)
34200 (T ALINK1)))
34300 (SETQ BVARS NIL)
34400 (RETURN (SETQ FRAME* NIL))))
34500 EXPR)
34600
34700 (DEFPROP SAVEV
34800 (LAMBDA NIL
34900 (MAPCAR (QUOTE (LAMBDA (V) (CONS V (VALUE V)))) SAVE))
35000 EXPR)
35100
35200 (COMMENT FUNCTION CALLS RETURN VIA "POPJ")
35300 (DEFPROP POPJ
35400 (LAMBDA NIL
35500 (COND ((SETQ FRAME* CLINK) (RESTORE)) (T (QUOTE *STOP))))
35600 EXPR)
35700
35800 (DEFPROP RESTORE
35900 (LAMBDA NIL
36000 (PROG NIL
36100 (SETQ BVARS (CAADR FRAME*))
36200 (SETQ ALINK (CDADR FRAME*))
36300 (SETQ EXP (CADDR FRAME*))
36400 (SETQ CLINK (CDDDR FRAME*))
36500 (RETURN (REST1))))
36600 EXPR)
36700
36800 (DEFPROP REST1
36900 (LAMBDA NIL
37000 (PROG NIL
37100 (MAPC (QUOTE (LAMBDA (X) (SET (CAR X) (CDR X))))
37200 (CAAR FRAME*))
37300 (RETURN (CDAR FRAME*))))
37400 EXPR)
37500
37600 (PUTPROP (QUOTE VALUE)
37700 (GET (QUOTE EVAL) (QUOTE LSUBR))
37800 (QUOTE LSUBR))
37900
38000 (DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))
38100
38200 (DEFPROP BIND1
38300 (LAMBDA(VAR VAL)
38400 (PROG NIL
38500 (SETQ BVARS (CONS (LIST VAR VAL) BVARS))
38600 (RETURN (SETQ CHALOBV T))))
38700 EXPR)
38800
38900 (DEFPROP CLOSE
39000 (LAMBDA NIL
39100 (COND ((ATOM (CAR EXP)))
39200 ((EQ (CAAR EXP) (QUOTE *CLOSURE))
39300 (SETQ ALINK (CADDAR EXP))
39400 (SETQ CHALOBV T))))
39500 EXPR)
39600
39700 (COMMENT MOBY BINDER 0 0 NORMAL FUNCTION LISTS)
39800
39900 (DEFPROP ARGB
40000 (LAMBDA NIL
40100 (COND ((NOT (OR VARS UARGS)) (CLOSE) (QUOTE AUXB))
40200 ((AND VARS UARGS)
40300 (COND
40400 ((ATOM (CAR VARS))
40500 (COND
40600 ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
40700 (SETQ VARS (CDR VARS))
40800 (OPTMATCH))
40900 ((EQ (CAR VARS) (QUOTE "REST"))
41000 (SETQ VARS (CDR VARS))
41100 (RESTMATCH))
41200 (T
41300 (DISPATCH (CAR UARGS)
41400 (QUOTE ARGB1)
41500 (QUOTE (VARS UARGS))
41600 ALINK))))
41700 ((AND (EQ (CAAR VARS) (QUOTE QUOTE))
41800 (ATOM (CADAR VARS)))
41900 (ARGQ))
42000 (T (CERR BAD DECLARATION))))
42100 ((AND VARS
42200 (OR (EQ (CAR VARS) (QUOTE "OPTIONAL"))
42300 (EQ (CAR VARS) (QUOTE "REST"))))
42400 (CLOSE)
42500 (FINVAR))
42600 (T (CERR WRONG # OF ARGS))))
42700 EXPR)
42800
42900 (DEFPROP ARGB1
43000 (LAMBDA NIL
43100 (PROG NIL
43200 (BIND1 (CAR VARS) VAL)
43300 (SETQ VARS (CDR VARS))
43400 (SETQ UARGS (CDR UARGS))
43500 (RETURN (QUOTE ARGB))))
43600 EXPR)
43700 (DEFPROP ARGQ
43800 (LAMBDA NIL
43900 (PROG NIL
44000 (BIND1 (CADAR VARS) (CAR UARGS))
44100 (SETQ VARS (CDR VARS))
44200 (SETQ UARGS (CDR UARGS))
44300 (RETURN (QUOTE ARGB))))
44400 EXPR)
44500
44600 (COMMENT BIND UP "OPTIONAL"S AND "REST"S)
44700
44800 (DEFPROP OPTMATCH
44900 (LAMBDA NIL
45000 (COND ((NULL UARGS) (CLOSE)
45100 (COND
45200 ((NULL VARS) (QUOTE AUXB))
45300 (T (QUOTE FINVAR))))
45400 ((ATOM (CAR VARS))
45500 (COND
45600 ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
45700 (SETQ VARS (CDR VARS))
45800 (QUOTE OPTMATCH))
45900 ((EQ (CAR VARS) (QUOTE "REST"))
46000 (SETQ VARS (CDR VARS))
46100 (QUOTE RESTMATCH))
46200 (T
46300 (DISPATCH (CAR UARGS)
46400 (QUOTE OPTMATCH1)
46500 (QUOTE (VARS UARGS))
46600 ALINK))))
46700 ((EQ (CAAR VARS) (QUOTE QUOTE))
46800 (COND
46900 ((ATOM (CADAR VARS))
47000 (BIND1 (CADAR VARS) (CAR UARGS))
47100 (SETQ VARS (CDR VARS))
47200 (SETQ UARGS (CDR UARGS))
47300 (QUOTE OPTMATCH))
47400 (T (CERR BAD DECLARATION))))
47500 ((ATOM (CAAR VARS))
47600 (DISPATCH (CAR UARGS)
47700 (QUOTE OPTMATCH1)
47800 (QUOTE (VARS UARGS))
47900 ALINK))
48000 ((AND (EQ (CAAAR VARS) (QUOTE QUOTE))
48100 (ATOM (CADAAR VARS)))
48200 (BIND1 (CADAAR VARS) (CAR UARGS))
48300 (SETQ VARS (CDR VARS))
48400 (SETQ UARGS (CDR UARGS))
48500 (QUOTE OPTMATCH))
48600 (T (CERR BAD DECLARATION))))
48700 EXPR)
48800
48900 (DEFPROP OPTMATCH1
49000 (LAMBDA NIL
49100 (PROG NIL
49200 (BIND1
49300 (COND ((ATOM (CAR VARS)) (CAR VARS))
49400 (T (CAAR VARS)))
49500 VAL)
49600 (SETQ VARS (CDR VARS))
49700 (SETQ UARGS (CDR UARGS))
49800 (RETURN (QUOTE OPTMATCH))))
49900 EXPR)
50000
50100 (DEFPROP RESTMATCH
50200 (LAMBDA NIL
50300 (COND ((ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST))
50400 ((AND (EQ (CAAR VARS) (QUOTE QUOTE))
50500 (ATOM (CADAR VARS)))
50600 (BIND1 (CADAR VARS) UARGS)
50700 (CLOSE)
50800 (QUOTE AUXB))
50900 (T (CERR BAD DECLARATION))))
51000 EXPR)
51100
51200 (DEFPROP EVREST
51300 (LAMBDA NIL
51400 (COND ((NULL UARGS) (BIND1 (CAR VARS) (REVERSE EARGS))
51500 (CLOSE)
51600 (QUOTE AUXB))
51700 (T
51800 (DISPATCH (CAR UARGS)
51900 (QUOTE EVREST1)
52000 (QUOTE (VARS UARGS EARGS))
52100 ALINK))))
52200 EXPR)
52300
52400 (DEFPROP EVREST1
52500 (LAMBDA NIL
52600 (PROG NIL
52700 (SETQ UARGS (CDR UARGS))
52800 (SETQ EARGS (CONS VAL EARGS))
52900 (RETURN (QUOTE EVREST))))
53000 EXPR)
53100
53200 (COMMENT WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S)
53300
53400 (DEFPROP FINVAR
53500 (LAMBDA NIL
53600 (COND ((NULL VARS) (QUOTE AUXB))
53700 ((ATOM (CAR VARS))
53800 (COND
53900 ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
54000 (SETQ VARS (CDR VARS))
54100 (QUOTE FINVAR))
54200 ((EQ (CAR VARS) (QUOTE "REST"))
54300 (SETQ VARS (CDR VARS))
54400 (COND
54500 ((ATOM (CAR VARS))
54600 (BIND1 (CAR VARS) NIL)
54700 (QUOTE AUXB))
54800 ((AND (EQ (CAAR VARS) (QUOTE QUOTE))
54900 (ATOM (CADAR VARS)))
55000 (BIND1 (CADAR VARS) NIL)
55100 (QUOTE AUXB))
55200 (T (CERR BAD DECLARATION))))
55300 (T (BIND1 (CAR VARS) (QUOTE *UNASSIGNED))
55400 (SETQ VARS (CDR VARS))
55500 (QUOTE FINVAR))))
55600 ((EQ (CAAR VARS) (QUOTE QUOTE))
55700 (COND
55800 ((ATOM (CADAR VARS))
55900 (BIND1 (CADAR VARS) (QUOTE *UNASSIGNED))
56000 (SETQ VARS (CDR VARS))
56100 (QUOTE FINVAR))
56200 (T (CERR BAD DECLARATION))))
56300 ((ATOM (CAAR VARS))
56400 (DISPATCH (CADAR VARS)
56500 (QUOTE FINVAR1)
56600 (QUOTE (VARS))
56700 (QUOTE *TOP)))
56800 ((AND (EQ (CAAAR VARS) (QUOTE QUOTE))
56900 (ATOM (CADAAR VARS)))
57000 (DISPATCH (CADAR VARS)
57100 (QUOTE FINVAR2)
57200 (QUOTE (VARS))
57300 (QUOTE *TOP)))
57400 (T (CERR BAD DECLARATION))))
57500 EXPR)
57600
57700 (DEFPROP FINVAR1
57800 (LAMBDA NIL
57900 (PROG NIL (BIND1 (CAAR VARS) VAL) (RETURN (FINVAR3))))
58000 EXPR)
58100 (DEFPROP FINVAR2
58200 (LAMBDA NIL
58300 (PROG NIL (BIND1 (CADAAR VARS) VAL) (RETURN (FINVAR3))))
58400 EXPR)
58500
58600 (DEFPROP FINVAR3
58700 (LAMBDA NIL
58800 (PROG NIL (SETQ VARS (CDR VARS)) (RETURN (QUOTE FINVAR))))
58900 EXPR)
59000
59100 (COMMENT BINDS "AUX" VARIABLES)
59200
59300 (DEFPROP AUXB
59400 (LAMBDA NIL
59500 (PROG NIL
59600 (SETQ BODY (BODY))
59700 (RETURN
59800 (COND ((NULL BODY) (POPJ))
59900 ((EQ (CAR BODY) (QUOTE "AUX"))
60000 (SETQ VARS (CADR BODY))
60100 (QUOTE AUXB1))
60200 (T (QUOTE LINE))))))
60300 EXPR)
60400
60500 (DEFPROP AUXB1
60600 (LAMBDA NIL
60700 (COND ((NULL VARS) (SETQ BODY (CDDR (BODY))) (QUOTE LINE))
60800 ((ATOM (CAR VARS)) (BIND1 (CAR VARS)
60900 (QUOTE *UNASSIGNED))
61000 (SETQ VARS (CDR VARS))
61100 (QUOTE AUXB1))
61200 ((AND (ATOM (CAAR VARS)) (CDAR VARS))
61300 (DISPATCH (CADAR VARS)
61400 (QUOTE AUXB2)
61500 (QUOTE (VARS))
61600 (QUOTE *TOP)))
61700 (T (CERR BAD DECLARATION))))
61800 EXPR)
61900
62000 (DEFPROP AUXB2
62100 (LAMBDA NIL
62200 (PROG NIL
62300 (BIND1 (CAAR VARS) VAL)
62400 (SETQ VARS (CDR VARS))
62500 (RETURN (QUOTE AUXB1))))
62600 EXPR)
62700
62800 (DEFPROP CPROG
62900 (LAMBDA NIL
63000 (PROG NIL
63100 (BIND1 (QUOTE *BODY) (CDR EXP))
63200 (RETURN (QUOTE AUXB))))
63300 EXPR)
63400
63500 (DEFPROP PROG CPROG CINT)
63600
63700 (DEFPROP PROGBIND
63800 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE PROGB1) NIL ALINK))
63900 EXPR)
64000
64100 (DEFPROP PROGB1
64200 (LAMBDA NIL
64300 (PROG NIL
64400 (BIND1 (QUOTE *BODY)
64500 (CONS (QUOTE "AUX")
64600 (CONS (SETQ VARS VAL) (CDDR EXP))))
64700 (RETURN (QUOTE AUXB1))))
64800 EXPR)
64900 (DEFPROP PROGBIND PROGBIND CINT)
65000
65100 (COMMENT BASIC PROG ITERATION LOOP)
65200
65300 (DEFPROP LINE
65400 (LAMBDA NIL
65500 (COND ((NULL BODY) (POPJ))
65600 (T
65700 (DISPATCH (CAR BODY)
65800 (QUOTE LINE1)
65900 (QUOTE (BODY))
66000 (QUOTE *TOP)))))
66100 EXPR)
66200
66300 (DEFPROP LINE1
66400 (LAMBDA NIL
66500 (PROG NIL (SETQ BODY (CDR BODY)) (RETURN (QUOTE LINE))))
66600 EXPR)
66700
66800 (COMMENT EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)
66900
67000 (DEFPROP EVARGS
67100 (LAMBDA NIL
67200 (COND ((NULL UARGS) (SETQ VAL
67300 (APPLY (CAR EXP)
67400 (REVERSE EARGS)))
67500 (POPJ))
67600 (T
67700 (DISPATCH (CAR UARGS)
67800 (QUOTE ARGS1)
67900 (QUOTE (UARGS EARGS))
68000 ALINK))))
68100 EXPR)
68200
68300 (DEFPROP ARGS1
68400 (LAMBDA NIL
68500 (PROG NIL
68600 (SETQ UARGS (CDR UARGS))
68700 (SETQ EARGS (CONS VAL EARGS))
68800 (RETURN (QUOTE EVARGS))))
68900 EXPR)
69000
69100 (COMMENT LOGICAL FLOW OF CONTROL FUNCTIONS)
69200
69300 (DEFPROP CCOND
69400 (LAMBDA NIL
69500 (PROG NIL (SETQ UARGS (CDR EXP)) (RETURN (CONDLP))))
69600 EXPR)
69700
69800 (DEFPROP CONDLP
69900 (LAMBDA NIL
70000 (COND ((NULL UARGS) (POPJ))
70100 (T
70200 (DISPATCH (CAAR UARGS)
70300 (QUOTE COND1)
70400 (QUOTE (UARGS))
70500 ALINK))))
70600 EXPR)
70700 (DEFPROP COND1
70800 (LAMBDA NIL
70900 (COND (VAL (BIND1 (QUOTE *BODY) (CDAR UARGS)) (QUOTE AUXB))
71000 (T (SETQ UARGS (CDR UARGS)) (QUOTE CONDLP))))
71100 EXPR)
71200
71300 (DEFPROP COND CCOND CINT)
71400
71500 (DEFPROP IAND
71600 (LAMBDA NIL
71700 (COND ((NULL (SETQ EXP (CDR EXP))) (OR VAL (SETQ VAL T))
71800 (POPJ))
71900 ((DISPATCH (CAR EXP)
72000 (QUOTE IAND1)
72100 (QUOTE (EXP))
72200 (QUOTE *TOP)))))
72300 EXPR)
72400
72500 (DEFPROP IAND1
72600 (LAMBDA NIL (COND (VAL (QUOTE IAND)) ((QUOTE POPJ))))
72700 EXPR)
72800
72900 (DEFPROP AND IAND CINT)
73000
73100 (DEFPROP IOR
73200 (LAMBDA NIL
73300 (COND
73400 ((NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ))
73500 ((DISPATCH (CAR EXP)
73600 (QUOTE IOR1)
73700 (QUOTE (EXP))
73800 (QUOTE *TOP)))))
73900 EXPR)
74000
74100 (DEFPROP IOR1 (LAMBDA NIL (COND (VAL (POPJ)) (T (QUOTE IOR)))) EXPR)
74200
74300 (DEFPROP OR IOR CINT)
74400
74500 (COMMENT USERS OF FRAMES 0 0 FLOW OF CONTROL CONTROLLERS)
74600
74700 (DEFPROP CGO
74800 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE GO1) NIL ALINK))
74900 EXPR)
75000 (DEFPROP GO1
75100 (LAMBDA NIL
75200 (COND ((ATOM VAL)
75300 (PROG (FR TAG B)
75400 (SETQ FR ALINK)
75500 (SETQ TAG (QUOTE (: FOO)))
75600 (RPLACA (CDR TAG) VAL)
75700 LP (COND ((NULL FR) (SETQ VAL
75800 (CERR TAG NOT FOUND))
75900 (QUOTE GO1))
76000 ((SETQ B
76100 (ASSQ (QUOTE *BODY) (BVARS FR)))
76200 (COND
76300 ((SETQ B (MEMBER TAG (CADR B)))
76400 (SETQ FRAME* FR)
76500 (RESTORE)
76600 (SETQ BODY B)
76700 (RETURN (QUOTE LINE))))))
76800 (SETQ FR (CLINK FR))
76900 (GO LP)))
77000 ((EQ (CAR VAL) (QUOTE *TAG))
77100 (SETQ FRAME* (CADDR VAL))
77200 (RESTORE))
77300 (T (SETQ VAL (CERR BAD TAG)) (QUOTE GO1))))
77400 EXPR)
77500
77600 (DEFPROP GO CGO CINT)
77700
77800 (DEFPROP CEXIT
77900 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE EXIT1) NIL ALINK))
78000 EXPR)
78100
78200 (DEFPROP EXIT1
78300 (LAMBDA NIL
78400 (PROG NIL
78500 (SETQ TEM VAL)
78600 (RETURN
78700 (COND
78800 ((CDDR EXP)
78900 (DISPATCH (CADDR EXP)
79000 (QUOTE EXIT2)
79100 (QUOTE (TEM))
79200 ALINK))
79300 (T
79400 (PROG (FR)
79500 (SETQ FR ALINK)
79600 LP (COND ((NULL FR) (CERR EXIT FROM WHAT?))
79700 ((ASSQ (QUOTE *BODY) (BVARS FR))
79800 (SETQ CLINK (CLINK FR))
79900 (RETURN (POPJ))))
80000 (SETQ FR (CLINK FR))
80100 (GO LP)))))))
80200 EXPR)
80300
80400 (DEFPROP EXIT2
80500 (LAMBDA NIL
80600 (PROG NIL
80700 (SETQ CLINK (CLINK (FR VAL)))
80800 (SETQ VAL TEM)
80900 (RETURN (POPJ))))
81000 EXPR)
81100
81200 (DEFPROP EXIT CEXIT CINT)
81300
81400 (DEFPROP CRETURN
81500 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE RETURN1) NIL ALINK))
81600 EXPR)
81700
81800 (DEFPROP RETURN1
81900 (LAMBDA NIL
82000 (PROG (FR)
82100 (SETQ FR ALINK)
82200 LP (COND ((NULL FR) (CERR RETURN FROM WHAT?))
82300 ((AND (ASSQ (QUOTE *BODY) (BVARS FR))
82400 (NOT (EQ (CAR (EXP FR)) (QUOTE COND))))
82500 (SETQ CLINK (CLINK FR))
82600 (RETURN (POPJ))))
82700 (SETQ FR (CLINK FR))
82800 (GO LP)))
82900 EXPR)
83000
83100 (DEFPROP RETURN CRETURN CINT)
83200
83300 (DEFPROP CDISMISS
83400 (LAMBDA NIL
83500 (COND ((CDR EXP) (SETQ TEM NIL)
83600 (DISPATCH (CADR EXP)
83700 (QUOTE EXIT2)
83800 (QUOTE (TEM))
83900 ALINK))
84000 (T (SETQ VAL NIL) (RETURN1))))
84100 EXPR)
84200 (DEFPROP DISMISS CDISMISS CINT)
84300
84400 (DEFPROP CONTINUE
84500 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CONT1) NIL ALINK))
84600 EXPR)
84700
84800 (DEFPROP CONT1
84900 (LAMBDA NIL
85000 (PROG NIL
85100 (SETQ TEM VAL)
85200 (RETURN
85300 (COND
85400 ((CDDR EXP)
85500 (DISPATCH (CADDR EXP)
85600 (QUOTE CONT2)
85700 (QUOTE (TEM))
85800 ALINK))
85900 (T (SETQ VAL NIL)
86000 (SETQ FRAME* (FR TEM))
86100 (RESTORE))))))
86200 EXPR)
86300
86400 (DEFPROP CONT2
86500 (LAMBDA NIL
86600 (PROG NIL (SETQ FRAME* (FR TEM)) (RETURN (RESTORE))))
86700 EXPR)
86800
86900 (DEFPROP CONTINUE CONTINUE CINT)
87000
87100 (COMMENT RELATIVE EVALUATORS)
87200
87300 (DEFPROP ICEVAL
87400 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CEVAL1) NIL ALINK))
87500 EXPR)
87600
87700 (DEFPROP CEVAL1
87800 (LAMBDA NIL
87900 (PROG NIL
88000 (SETQ TEM1 VAL)
88100 (RETURN
88200 (COND
88300 ((CDDR EXP)
88400 (DISPATCH (CADDR EXP)
88500 (QUOTE CEVAL2)
88600 (QUOTE (TEM1))
88700 ALINK))
88800 (T (SETQ VAL (FRAME)) (QUOTE CEVAL2))))))
88900 EXPR)
89000
89100 (DEFPROP CEVAL2
89200 (LAMBDA NIL (DISPATCH TEM1 (QUOTE POPJ) NIL (FR VAL)))
89300 EXPR)
89400
89500 (DEFPROP CEVAL ICEVAL CINT)
89600 (DEFPROP ICALL
89700 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CALL1) NIL ALINK))
89800 EXPR)
89900
90000 (DEFPROP CALL1
90100 (LAMBDA NIL
90200 (DISPATCH (CONS VAL (CDDR EXP)) (QUOTE POPJ) NIL ALINK))
90300 EXPR)
90400
90500 (DEFPROP CALL ICALL CINT)
90600
90700 (DEFPROP INVOKE
90800 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE TRY1) NIL ALINK))
90900 EXPR)
91000
91100 (DEFPROP TRY1
91200 (LAMBDA NIL
91300 (PROG NIL
91400 (SETQ TEM VAL)
91500 (RETURN
91600 (DISPATCH (CADDR EXP)
91700 (QUOTE TRY2)
91800 (QUOTE (TEM))
91900 ALINK))))
92000 EXPR)
92100
92200 (DEFPROP TRY2
92300 (LAMBDA NIL
92400 (PROG NIL
92500 (SETQ EXP (LIST TEM VAL))
92600 (SETQ FRAME* NIL)
92700 (RETURN
92800 (PROG (AL METHPAT)
92900 (COND
93000 ((NULL
93100 (SETQ AL
93200 (MATCH (SETQ METHPAT (PATTERN TEM))
93300 VAL)))
93400 (RETURN (POPJ)))
93500 (T (SETQ BVARS
93600 (NCONC
93700 (LIST
93800 (LIST (QUOTE *CALLPAT) VAL)
93900 (LIST (QUOTE *METHPAT) METHPAT)
94000 (LIST
94100 (QUOTE *CALLALIST)
94200 (CADR AL))
94300 (LIST (QUOTE *BODY) (TEXT TEM)))
94400 (CAR AL)))
94500 (CLOSE)
94600 (RETURN (QUOTE AUXB))))))))
94700 EXPR)
94800
94900 (DEFPROP INVOKE INVOKE CINT)
95000
95100 (DEFPROP TEXT
95200 (LAMBDA(METH)
95300 (COND ((ATOM METH) (TEXT (GET METH (QUOTE DATUM))))
95400 ((EQ (CAR METH) (QUOTE *CLOSURE)) (TEXT (CADR METH)))
95500 (T (CADDDR METH))))
95600 EXPR)
95700
95800 (DEFPROP FR
95900 (LAMBDA(E)
96000 (COND ((EQ (CAR E) (QUOTE *FRAME)) (CADR E))
96100 ((EQ (CAR E) (QUOTE *TAG)) (CADDR E))
96200 ((EQ (CAR E) (QUOTE *CLOSURE)) (CADDR E))
96300 ((EQ (CAR E) (QUOTE *AU-REVOIR)) (CADR E))
96400 (T (CERR BAD FRAME SUPPLIED))))
96500 EXPR)
96600
96700 (COMMENT IDENTIFIER MANIPULATORS)
96800 (DEFPROP VFRAME
96900 (LAMBDA N
97000 (PROG (FR LOC)
97100 (SETQ FR
00100 (COND ((= N 1) ALINK)
00200 ((= N 2) (FR (ARG 2)))
00300 (T (CERR WRONG # OF ARGS))))
00400 LP (COND ((NULL FR) (RETURN NIL))
00500 ((SETQ LOC (ASSQ (ARG 1) (BVARS FR)))
00600 (RETURN
00700 (LIST (QUOTE *FRAME) (CHAUX FR) LOC))))
00800 (SETQ FR (ALINK FR))
00900 (GO LP)))
01000 EXPR)
01100
01200 (DEFPROP VLOC
01300 (LAMBDA N
01400 (PROG (FR LOC)
01500 (SETQ FR
01600 (COND
01700 ((= N 1)
01800 (COND
01900 ((SETQ LOC (ASSQ (ARG 1) BVARS))
02000 (RETURN LOC)))
02100 ALINK)
02200 ((= N 2) (FR (ARG 2)))
02300 (T (CERR WRONG # OF ARGS))))
02400 LP (COND ((NULL FR) (RETURN (ASSQ (ARG 1) GLOBALS)))
02500 ((SETQ LOC (ASSQ (ARG 1) (BVARS FR)))
02600 (RETURN LOC)))
02700 (SETQ FR (ALINK FR))
02800 (GO LP)))
02900 EXPR)
03000
03100 (DEFPROP RVALUE
03200 (LAMBDA N
03300 ((LAMBDA(LOC)
03400 (COND
03500 (LOC (COND
03600 ((CDDR LOC)
03700 (APPLY (CADDR LOC) (LIST (QUOTE RVALUE) LOC))))
03800 (CADR LOC))
03900 (T (CERR UNBOUND VARIABLE @ (ARG 1)))))
04000 (COND ((= N 1) (VLOC (ARG 1)))
04100 ((= N 2) (VLOC (ARG 1) (ARG 2)))
04200 (T (CERR WRONG # OF ARGS)))))
04300 EXPR)
04400
04500 (DECLARE (SPECIAL ID))
04600
04700 (DEFPROP IVAL
04800 (LAMBDA(ID FR)
04900 (PROG (ANS)
05000 (COND
05100 ((EQ FR (QUOTE *TOP))
05200 (COND
05300 ((SETQ ANS (ASSQ ID BVARS)) (GO FOUND))
05400 (T (SETQ FR ALINK)))))
05500 LP (COND
05600 ((NULL FR)
05700 (COND
05800 ((SETQ ANS (ASSQ ID GLOBALS)) (GO FOUND))
05900 (T (RETURN (CERR UNBOUND VARIABLE (@ . ID))))))
06000 ((SETQ ANS (ASSQ ID (BVARS FR))) (GO FOUND)))
06100 (SETQ FR (ALINK FR))
06200 (GO LP)
06300 FOUND
06400 (COND
06500 ((CDDR ANS)
06600 (APPLY (CADDR ANS) (LIST (QUOTE /,) ANS))))
06700 (COND
06800 ((EQ (SETQ ANS (CADR ANS)) (QUOTE *UNASSIGNED))
06900 (RETURN (CERR UNASSIGNED VARIABLE (@ . ID)))))
07000 (RETURN ANS)))
07100 EXPR)
07200
07300 (DECLARE (UNSPECIAL ID))
07400
07500 (DEFPROP ICSETQ
07600 (LAMBDA NIL (PROG NIL (SETQ UARGS EXP) (RETURN (CSETQ0))))
07700 EXPR)
07800
07900 (DEFPROP CSETQ0
08000 (LAMBDA NIL
08100 (COND
08200 ((CDR UARGS)
08300 (COND
08400 ((AND (ATOM (CADR UARGS)) (CDDR UARGS))
08500 (DISPATCH (CADDR UARGS)
08600 (QUOTE CSETQ1)
08700 (QUOTE (UARGS))
08800 ALINK))
08900 (T (CERR BAD CALL) (POPJ))))
09000 (T (POPJ))))
09100 EXPR)
09200
09300 (DEFPROP CSETQ1
09400 (LAMBDA NIL
09500 (PROG NIL
09600 ((LAMBDA(LOC)
09700 (COND
09800 (LOC
09900 (COND
10000 ((CDDR LOC)
10100 (APPLY (CADDR LOC)
10200 (LIST (QUOTE CSET) LOC VAL))))
10300 (RPLACA (CDR LOC) VAL))
10400 (T
10500 (SETQ GLOBALS
10600 (CONS (LIST (CADR UARGS) VAL) GLOBALS)))))
10700 (VLOC (CADR UARGS)))
10800 (SETQ UARGS (CDDR UARGS))
10900 (RETURN (QUOTE CSETQ0))))
11000 EXPR)
11100
11200 (DEFPROP CSETQ (LAMBDA (L) (CSET (CAR L) (EVAL (CADR L)))) FEXPR)
11300 (DEFPROP CSETQ ICSETQ CINT)
11400
11500 (DEFPROP CSET
11600 (LAMBDA N
11700 ((LAMBDA(LOC)
11800 (PROG NIL
11900 (COND
12000 (LOC
12100 (COND
12200 ((CDDR LOC)
12300 (APPLY (CADDR LOC)
12400 (LIST (QUOTE CSET) LOC (ARG 2)))))
12500 (RPLACA (CDR LOC) (ARG 2)))
12600 (T
12700 (SETQ GLOBALS
12800 (CONS (LIST (ARG 1) (ARG 2)) GLOBALS))))
12900 (RETURN (ARG 2))))
13000 (COND ((= N 2) (VLOC (ARG 1)))
13100 ((= N 3) (VLOC (ARG 1) (ARG 3)))
13200 (T (CERR WRONG # OF ARGS)))))
13300 EXPR)
13400
13500 (DEFPROP UNASSIGN (LAMBDA (VAR) (CSET VAR (QUOTE *UNASSIGNED))) EXPR)
13600
13700 (COMMENT FRAME CONSTRUCTORS)
13800
13900 (DEFPROP CHAUX
14000 (LAMBDA(FR)
14100 (COND ((NULL FR) NIL)
14200 ((EQ (CDAR FR) (QUOTE AUXB1))
14300 (CERR ATTEMPT TO RETURN INCOMPLETE FRAME))
14400 (T FR)))
14500 EXPR)
14600
14700 (DEFPROP TAG
14800 (LAMBDA(NAME)
14900 (PROG (FR B TAG)
15000 (SETQ FR ALINK)
15100 (SETQ TAG (QUOTE (: FOO)))
15200 (RPLACA (CDR TAG) NAME)
15300 LP (COND ((NULL FR) (RETURN NIL))
15400 ((SETQ B (ASSQ (QUOTE *BODY) (BVARS FR)))
15500 (COND
15600 ((SETQ B (MEMBER TAG (CADR B)))
15700 (CHAUX FR)
15800 (RETURN
15900 (LIST (QUOTE *TAG)
16000 NAME
16100 (CONS
16200 (CONS
16300 (LIST (CONS (QUOTE BODY) B))
16400 (QUOTE LINE))
16500 (CDR FR))))))))
16600 (SETQ FR (CLINK FR))
16700 (GO LP)))
16800 EXPR)
16900
17000 (DEFPROP ACTBLOCK
17100 (LAMBDA NIL
17200 (PROG (FR B)
17300 (SETQ FR ALINK)
17400 LP (COND ((NULL FR) (RETURN NIL))
17500 ((SETQ B (ASSQ (QUOTE *BODY) (BVARS FR)))
17600 (CHAUX FR)
17700 (COND
17800 ((EQ (CAR B) (QUOTE "AUX"))
17900 (SETQ B (CDDR B))))
18000 (RETURN
18100 (LIST (QUOTE *TAG)
18200 (QUOTE *ACTBLOCK)
18300 (CONS
18400 (CONS
18500 (LIST (CONS (QUOTE BODY) B))
18600 (QUOTE LINE))
18700 (CDR FR))))))
18800 (SETQ FR (CLINK FR))
18900 (GO LP)))
19000 EXPR)
19100
19200 (DEFPROP ACCESS
19300 (LAMBDA N
19400 (LIST (QUOTE *FRAME)
19500 (CHAUX
19600 (COND ((= N 0) (ALINK ALINK))
19700 ((= N 1) (ALINK (FR (ARG 1))))
19800 (T (CERR WRONG # OF ARGS))))))
19900 EXPR)
20000
20100 (DEFPROP CONTROL
20200 (LAMBDA N
20300 (LIST (QUOTE *FRAME)
20400 (CHAUX
20500 (COND ((= N 0) (CLINK ALINK))
20600 ((= N 1) (CLINK (FR (ARG 1))))
20700 (T (CERR WRONG # OF ARGS))))))
20800 EXPR)
20900
21000 (DEFPROP CLOSURE
21100 (LAMBDA N
21200 (PROG NIL
21300 (COND ((OR (< N 1) (> N 2)) (CERR WRONG # OF ARGS)))
21400 (RETURN
21500 (LIST (QUOTE *CLOSURE)
21600 (ARG 1)
21700 (CHAUX
21800 (COND ((= N 2) (FR (ARG 2))) (T ALINK)))))))
21900 EXPR)
22000 (DEFPROP FRAME (LAMBDA NIL (LIST (QUOTE *FRAME) (CHAUX ALINK))) EXPR)
22100
22200 (COMMENT VERY DANGEROUS USER (HA!) FUNCTIONS)
22300
22400 (DEFPROP SETACCESS
22500 (LAMBDA(T1 S)
22600 (PROG NIL
22700 (SETQ T1 (FR T1))
22800 (SETQ S (FR S))
22900 (RPLACD (CADR T1) S)
23000 (RETURN (QUOTE BOOM!))))
23100 EXPR)
23200
23300 (DEFPROP SETCONTROL
23400 (LAMBDA(T1 S)
23500 (PROG NIL
23600 (SETQ T1 (FR T1))
23700 (SETQ S (FR S))
23800 (RPLACD (CDDR T1) S)
23900 (RETURN (QUOTE BOOM!))))
24000 EXPR)
24100
24200 (DEFPROP CEVAL
24300 (LAMBDA N
24400 ((LAMBDA(PC EXP ALINK)
24500 (PROG (CLINK FRAME* BVARS CHALOBV RUNF) (RETURN (RUN1))))
24600 (QUOTE ICEVAL)
24700 (LIST (QUOTE CEVAL) (LIST (QUOTE QUOTE) (ARG 1)))
24800 (COND ((> N 1) (FR (ARG 2))) (T ALINK))))
24900 EXPR)
25000
25100 (COMMENT DEBUGGING AIDS)
25200
25300 (DEFPROP EXPRESSION (LAMBDA (F) (EXP (FR F))) EXPR)
25400
25500 (DEFPROP BACKTRACE
25600 (LAMBDA N
25700 (PROG (FR E B M TEM)
25800 (SETQ FR (FRAME))
25900 (COND ((= N 0) (SETQ M 777777)) (T (SETQ M (ARG 1))))
26000 (COND ((= N 2) (SETQ TEM (ARG 2))))
26100 LP (COND
26200 ((OR (NULL (CADR FR)) (= M 0))
26300 (RETURN (QUOTE END-OF-BACKTRACE))))
26400 (SETQ E (EXPRESSION FR))
26500 (COND
26600 ((SETQ B (GET (CAR E) (QUOTE BACKTRACE)))
26700 (APPLY B (LIST FR (CDR E))))
26800 (T (CPRINT E)))
26900 (COND (TEM (CPRIN1 (CAADR FR))))
27000 (SETQ FR (CONTROL FR))
27100 (SETQ M (/1- M))
27200 (GO LP)))
27300 EXPR)
27400
27500 (DEFPROP LISTENB
27600 (LAMBDA(FR ARG)
27700 (PROG NIL
27800 (PRINT (IVAL (QUOTE EAR) (CADR FR)))
27900 (CPRIN1 (IVAL (QUOTE MESSAGE) (CADR FR)))
28000 (RETURN (PRINC (QUOTE / )))))
28100 EXPR)
28200
28300 (DEFPROP LISTEN LISTENB BACKTRACE)
28400 (DEFPROP CONDB (LAMBDA (FR ARG) (PRINT (QUOTE COND))) EXPR)
28500
28600 (DEFPROP COND CONDB BACKTRACE)
28700
28800 (DEFPROP PROGB (LAMBDA (FR ARG) (PRINT (QUOTE PROG))) EXPR)
28900
29000 (DEFPROP PROG PROGB BACKTRACE)
29100
29200 (DEFPROP CEVALB
29300 (LAMBDA (FR ARG) (COND (TEM (PRINT (QUOTE CEVAL)))))
29400 EXPR)
29500
29600 (DEFPROP CEVAL CEVALB BACKTRACE)
29700
29800 (DEFPROP UPDATEB (LAMBDA (FR ARG) NIL) EXPR)
29900
30000 (DEFPROP UPDATE UPDATEB BACKTRACE)
30100
30200 (DEFPROP SETB
30300 (LAMBDA(FR ARG)
30400 (OR (MEMBER (CAR ARG) (QUOTE ((QUOTE *) (QUOTE **))))
30500 (PRINT (CONS (QUOTE SET) ARG))))
30600 EXPR)
30700
30800 (DEFPROP SET SETB BACKTRACE)
30900 (DEFPROP PROGBINDB (LAMBDA (FR ARG) (PRINT (QUOTE PROGBIND))) EXPR)
31000
31100 (DEFPROP PROGBIND PROGBINDB BACKTRACE)
31200
31300 (COMMENT USER INTERFACE)
31400
31500 (DEFPROP CDEFUN
31600 (LAMBDA(L)
31700 (PROG NIL
31800 (PUTPROP (CAR L) (CDR L) (QUOTE CEXPR))
31900 (RETURN (CAR L))))
32000 FEXPR)
32100
32200 (CDEFUN LISTEN
32300 (MESSAGE)
32400 "AUX"
32500 ((EAR (GENLEV)))
32600 (ALLOW T)
32700 (CPRINT MESSAGE)
32800 (PROGBIND (LIST EAR (QUOTE LOOP))
32900 (CSET EAR (TAG (QUOTE EAR)))
33000 (CSETQ LOOP (TAG (QUOTE LOOP)))
33100 (: EAR)
33200 (PRINT EAR)
33300 (: LOOP)
33400 (SETQ ← **)
33500 (@ PRINT (QUOTE ←))
33600 (SET (QUOTE *) (CEVAL (SETQ ** (READ))))
33700 (@ CPRINT *)
33800 (GO LOOP)))
33900
34000 (DEFPROP GENLEV
34100 (LAMBDA NIL
34200 (READLIST
34300 (APPEND (QUOTE (E A R _))
34400 (EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
34500 EXPR)
34600
34700 (DEFPROP : (LAMBDA (L) L) FEXPR)
34800
34900 (DEFPROP @ (LAMBDA (\L) (EVAL \L)) FEXPR)
35000
35100 (DEFPROP /, (LAMBDA (L) (IVAL (CAR L) (QUOTE *TOP))) FEXPR)
35200
35300 (DEFPROP CPRIN1
35400 (LAMBDA(X)
35500 (PROG (Y)
35600 (COND ((ATOM X) (PRIN1 X) (RETURN X))
35700 ((AND (ATOM (CAR X))
35800 (SETQ Y (GET (CAR X) (QUOTE CPRINT))))
35900 (APPLY Y X)
36000 (RETURN X)))
36100 (SETQ Y X)
36200 (PRINC (QUOTE /())
36300 PLOOP
36400 (CPRIN1 (CAR Y))
36500 (COND
36600 ((NULL (SETQ Y (CDR Y)))
36700 (PRINC (QUOTE /)))
36800 (RETURN X))
36900 ((ATOM Y) (PRINC (QUOTE / /./ ))
37000 (PRIN1 Y)
37100 (PRINC (QUOTE /)))
37200 (RETURN X)))
37300 (PRINC (QUOTE / ))
37400 (GO PLOOP)))
37500 EXPR)
37600 (DEFPROP CPRINT
37700 (LAMBDA(X)
37800 (PROG NIL
37900 (TERPRI)
38000 (CPRIN1 X)
38100 (PRINC (QUOTE / ))
38200 (RETURN X)))
38300 EXPR)
38400
38500 (DEFPROP CP-MACR
38600 (LAMBDA(E)
38700 (PROG NIL (PRINC (CAR E)) (RETURN (PRIN1 (CADR E)))))
38800 FEXPR)
38900
39000 (DEFPROP : CP-MACR CPRINT)
39100
39200 (DEFPROP /, CP-MACR CPRINT)
39300
39400 (DEFPROP CP-QUOTE
39500 (LAMBDA(E)
39600 (PROG NIL (PRINC (QUOTE /')) (RETURN (CPRIN1 (CADR E)))))
39700 FEXPR)
39800
39900 (DEFPROP QUOTE CP-QUOTE CPRINT)
40000
40100 (DEFPROP CP-*TAG
40200 (LAMBDA(TAG)
40300 (PROG NIL
40400 (PRINC (QUOTE /())
40500 (PRIN1 (CAR TAG))
40600 (PRINC (QUOTE / ))
40700 (CPRIN1 (CADR TAG))
40800 (PRINC (QUOTE / ))
40900 (CPRIN1 (EXP (CADDR TAG)))
41000 (RETURN (PRINC (QUOTE /))))))
41100 FEXPR)
41200
41300 (DEFPROP *TAG CP-*TAG CPRINT)
41400
41500 (DEFPROP *CLOSURE CP-*TAG CPRINT)
41600
41700 (DEFPROP CP-*FRAME
41800 (LAMBDA(FRAME)
41900 (PROG NIL
42000 (PRINC (QUOTE /())
42100 (PRIN1 (CAR FRAME))
42200 (PRINC (QUOTE / ))
42300 (CPRIN1 (EXP (CADR FRAME)))
42400 (RETURN (PRINC (QUOTE /))))))
42500 FEXPR)
42600 (DEFPROP *FRAME CP-*FRAME CPRINT)
42700
42800 (DEFPROP *AU-REVOIR CP-*FRAME CPRINT)
42900
43000 (DEFPROP CP-MATCH
43100 (LAMBDA(E)
43200 (PROG NIL
43300 (PRINC (CAR E))
43400 (RETURN
43500 (COND ((CDDR E) (CPRIN1 (CDR E)))
43600 ((CADR E) (CPRIN1 (CADR E)))))))
43700 FEXPR)
43800
43900 (DEFPROP !> CP-MATCH CPRINT)
44000
44100 (DEFPROP !' CP-MATCH CPRINT)
44200
44300 (DEFPROP !? CP-MATCH CPRINT)
44400
44500 (DEFPROP !; CP-MATCH CPRINT)
44600
44700 (DEFPROP !< CP-MATCH CPRINT)
44800
44900 (DEFPROP !/, CP-MATCH CPRINT)
45000
45100 (DEFPROP !@ CP-MATCH CPRINT)
45200 (DEFPROP CP-!"
45300 (LAMBDA(E)
45400 (PROG NIL (PRINC (CAR E)) (RETURN (CPRIN1 (CDR E)))))
45500 FEXPR)
45600
45700 (DEFPROP !" CP-!" CPRINT)
45800
45900 (DEFPROP @ CP-!" CPRINT)
46000
46100 (DEFPROP COLMAC (LAMBDA NIL (LIST (QUOTE :) (READ))) EXPR)
46200
46300 (DEFPROP COMMAC (LAMBDA NIL (LIST (QUOTE /,) (READ))) EXPR)
46400
46500 (DEFPROP ATMAC (LAMBDA NIL (CONS (QUOTE @) (READ))) EXPR)
46600
46700 (DEFPROP EXMAC
46800 (LAMBDA NIL
46900 (PROG (C F)
47000 (SETQ C (NXTCHR))
47100 (COND ((EQ C (QUOTE $)) (TYI)
47200 (RETURN
47300 ((LAMBDA (OBARRAY) (READ))
47400 (GET
47500 (QUOTE CONNIVER)
47600 (QUOTE ARRAY)))))
47700 ((EQ C (QUOTE ")) (TYI)
47800 (RETURN
47900 (CONS (QUOTE !") (READ))))
48000 ((SETQ F
48100 (ASSQ C
48200 (QUOTE
48300 ((? !?) (/' !')
48400 (@ !@)
48500 (> !>)
48600 (/, !/,)
48700 (< !<)
48800 (; !;)))))
48900 (TYI)
49000 (SETQ F (CADR F)))
49100 (T (PRINT
49200 (LIST (QUOTE BAD)
49300 (QUOTE !)
49400 (QUOTE MACRO)
49500 C))
49600 (IOC G)))
49700 (RETURN
49800 (COND ((SEPARATOR (NXTCHR)) (LIST F NIL))
49900 ((ATOM (SETQ C (READ))) (LIST F C))
50000 (T (CONS F C))))))
50100 EXPR)
50200
50300 (DEFPROP NXTCHR (LAMBDA NIL (ASCII (TYIPEEK))) EXPR)
50400
50500 (DEFPROP SEPARATOR
50600 (LAMBDA (CHAR) (MEMQ CHAR (QUOTE (/ / /)))))
50700 EXPR)
50800
50900 (MAKREADTABLE (QUOTE CONNIVREAD))
51000 ((LAMBDA(READTABLE)
51100 (PROG NIL
51200 (SSTATUS MACRO : (QUOTE COLMAC))
51300 (SSTATUS MACRO /, (QUOTE COMMAC))
51400 (SSTATUS MACRO @ (QUOTE ATMAC))
51500 (RETURN (SSTATUS MACRO ! (QUOTE EXMAC)))))
51600 (GET (QUOTE CONNIVREAD) (QUOTE ARRAY)))
00100
00200
00250 (DECLARE (SPECIAL A))
00300 (DEFPROP CERR
00400 (LAMBDA(L )
00500 (PROG (Z CHN)
00550 (SETQ CHN(INC NIL NIL))
00575 (UNMACIT)(MACIT)
00600 (PRINT (QUOTE **ERROR**))
00700 (MAPC (QUOTE
00800 (LAMBDA(X)
00900 (CPRIN1 (COND ((ATOM X) X) ((EQ (CAR X) (QUOTE /@)) (EVAL (CDR X) )) (T X)))
01000 (PRINC (QUOTE / ))))
01100 L)
01200 (CPRINT EXP)
01300 (PRINT (QUOTE IN-LISP))
01400 LP (PRINC (QUOTE *))
01500 (SETQ Z (ERRSET
01600 (COND ((EQ (SETQ ** (READ)) (QUOTE $P))**)
01700 ((EQ (CAR **) (QUOTE RETURN)) (EVAL (CADR **) ))
01800 (T (SETQ * (CPRINT (EVAL ** )))))))
01900 (SETQ ← **)
02000 (COND((ATOM Z)(GO LP))
02050 ((EQ(CAR **)(QUOTE RETURN))(INC CHN)(CONIVE)(RETURN (CAR Z)))
02075 ((EQ(CAR Z) (QUOTE $P))(INC CHN)(CONIVE)(RETURN NIL)))
02100 (GO LP)))
02200 FEXPR)
02300 (DECLARE (UNSPECIAL A))